home *** CD-ROM | disk | FTP | other *** search
/ Business Shareware / Business Shareware.iso / start / database / lib194 / array.prg next >
Encoding:
Text File  |  1992-12-23  |  30.2 KB  |  830 lines
  1. *-------------------------------------------------------------------------------
  2. *-- Program...: ARRAY.PRG
  3. *-- Programmer: Ken Mayer (CIS: 71333,1030)
  4. *-- Date......: 07/07/1992
  5. *-- Notes.....: These routines deal with filling arrays, sorting arrays, 
  6. *--             and so on ... See README.TXT for details on using this file.
  7. *-------------------------------------------------------------------------------
  8.  
  9. FUNCTION Afill
  10. *-------------------------------------------------------------------------------
  11. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  12. *-- Date........: 04/22/1992
  13. *-- Notes.......: Creates if needed, and fills a row or column of, an array,
  14. *--               with sequential numeric elements starting with nFirst,
  15. *--               increasing by nStep.
  16. *--               Useful for testing routines that require an array ...
  17. *-- Written for.: dBASE IV, 1.1
  18. *-- Rev. History: Original function 03/01/1992.
  19. *--               04/22/92 - Jay Parsons - calling syntax changed
  20. *-- Calls.......: AMASK()              Functon in ARRAY.PRG
  21. *-- Called by...: Any
  22. *-- Usage.......: AFill("<cArrayskel>",<nCount>,<nFirstVal>,<nStep>)
  23. *-- Example.....: lX = AFill("aTest",20,1,10)
  24. *-- Returns.....: .T. (and an array filled with values as in "notes" above)
  25. *-- Parameters..: cArrayskel  = Name of array and optional row/column info
  26. *--               nCount      = number of elements to fill
  27. *--               nFirstVal   = starting value in array
  28. *--               nStep       = number to increment by
  29. *-- Side effects: Creates as public, if needed, and fills array.  Will destroy
  30. *--               existing array of the same name if its dimensions are
  31. *--               inadequate for the data to be filled in.
  32. *-------------------------------------------------------------------------------
  33.  
  34.    parameters cArrayskel, nCount, nFirstval, nStep
  35.    private nAt, cArray, cMask, cElem, nRows, nCols, nFill
  36.    cArray = cArrayskel
  37.    if "[" $ cArray
  38.       cArray = left( cArray, at( "[", cArray ) - 1 )
  39.    endif
  40.    cArray = trim( ltrim( cArray ) )
  41.    cMask = Amask( cArrayskel, "nAt" )
  42.    if at( ",", cMask ) > 0 .and. val( substr( cMask, at( ",", cMask ) + 1 ) ) = 0
  43.       nRows = val( substr( cMask, at( "[", cMask ) + 1 ) )
  44.       nCols = nCount
  45.    else
  46.       nRows = nCount
  47.       nCols = val( substr( cMask, at( ",", cMask ) + 1 ) )
  48.    endif
  49.    nAt = nCount
  50.    cElem = cArray + cMask
  51.    if type( cElem ) = "U"
  52.       release &cArray
  53.       public &cArray
  54.       if nCols > 0
  55.          declare &cArray[ nRows, nCols ]
  56.       else
  57.          declare &cArray[ nRows ]
  58.       endif
  59.    endif
  60.    nFill = nFirstval
  61.    nAt = 0
  62.    do while nAt < nCount
  63.       nAt = nAt + 1
  64.       cElem = cArray + cMask
  65.       store nFill to &cElem
  66.       nFill = nFill + nStep
  67.    enddo
  68.     
  69. RETURN .T.
  70. *-- EoF: Afill()
  71.  
  72. FUNCTION Amask
  73. *-------------------------------------------------------------------------------
  74. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  75. *-- Date........: 04/21/1992
  76. *-- Notes.......: Returns a "mask" specifying the desired row or column of
  77. *--               an array.
  78. *-- Written for.: dBASE IV
  79. *-- Rev. History: None
  80. *-- Calls       : None
  81. *-- Called by...: Any
  82. *-- Usage.......: Amask( <cArrayskel>, <cVar> )
  83. *-- Example.....: ? Amask( "Myarray [ , 1 ]", "nAt" )
  84. *-- Returns     : a character value including a passed character string,
  85. *--               which may be used by the calling function to locate array
  86. *--               elements
  87. *-- Parameters..: cArrayskel, a character string including the name of the
  88. *--               array and, if the row or column to be used is not the
  89. *--               first row (or only row if array is one-dimensional),
  90. *--               a bracketed expression with a number indicating the row,
  91. *-                or column if the number is preceded by a comma, to be used.
  92. *--               cVar, name of the memvar to be used by calling function.
  93. *-------------------------------------------------------------------------------
  94.  
  95.    parameters cArrayskel, cVar
  96.    private nAt, cWhich, cMask, cV
  97.    nAt = at( "[", cArrayskel )
  98.    cWhich = "0 ]"
  99.    cV = trim( ltrim( cVar ) )
  100.    if nAt > 0
  101.       cWhich = substr( cArrayskel, nAt + 1 )
  102.    else
  103.       cWhich = "1 ]"
  104.    endif
  105.    if .not. "," $ cArrayskel
  106.       cMask = "[ " + cV + " ]"
  107.    else
  108.       if val( cWhich ) > 0
  109.          cMask = "["+ ltrim( str( val( cWhich ) ) ) + "," + cV + "]"
  110.       else
  111.          cWhich = substr( cWhich, at( ",", cWhich ) + 1 )
  112.          cMask = "[" + cV+ ","+ ltrim( str( val( cWhich ) ) ) + "]"
  113.       endif
  114.    endif
  115.  
  116. RETURN cMask
  117. *-- EoF: Amask()
  118.  
  119. FUNCTION Amean
  120. *-------------------------------------------------------------------------------
  121. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  122. *-- Date........: 04/13/1992
  123. *-- Notes.......: Mean of non-blank numeric or date values in specified row
  124. *--             : or column of a specified array.  If the first value is a
  125. *--             : date, averages only dates.  If first value is numeric or
  126. *--             : float, averages only numerics and floats.  Exits returning
  127. *--             : .F. if first value is character or logical, if specified
  128. *--             : row or column does not exist or if there are no
  129. *--             : averageable values.
  130. *-- Written for.: dBASE IV Version 1.5.
  131. *-- Rev. History: Original function written 1990
  132. *--             : Adapted to Version 1.5 4/13/1992
  133. *-- Calls       : AMASK()              Function in ARRAY.PRG
  134. *-- Called by...: Any
  135. *-- Usage.......: Amean( <cArrayskel> )
  136. *-- Example.....: ? Amean( "Myarray [ , 1 ]" )
  137. *-- Returns     : a numeric, float or date value, the mean or average, or .F.
  138. *--             : If any of the averaged items are floats, the result will be.
  139. *-- Parameters..: cArrayskel, a character string including the name of the
  140. *--             : array and, if the row or column to be averaged is not the
  141. *--             : first row, a bracketed expression with a number indicating
  142. *--             : the row, or column if the number is preceded by a comma,
  143. *--             : to be averaged.
  144. *-------------------------------------------------------------------------------
  145.  
  146.    parameters cArrayskel
  147.    private nAt,cArray,cMask,cElem,nTot,nCount,xNext,cOktype
  148.    cArray = cArrayskel
  149.    if "[" $ cArray
  150.       cArray = left( cArray, at( "[", cArray ) - 1 )
  151.    endif
  152.    cArray = trim( ltrim( cArray ) )
  153.    cMask = Amask( cArrayskel, "nAt" )
  154.    store 0 to nTot, nCount, nAt
  155.    do while .t.
  156.       nAt = nAt + 1
  157.       cElem = cArray + cMask
  158.       xNext = type( cElem )
  159.       do case
  160.          case xNext = "U"
  161.             exit
  162.          case nAt = 1
  163.             if xNext $ "CL"
  164.                exit
  165.             else
  166.                cOktype = iif( xNext = "D", "D", "NF" )
  167.             endif
  168.          case .not. xNext $ cOktype
  169.             loop
  170.       endcase
  171.       xNext = &cElem
  172.       if isblank( xNext )
  173.          loop
  174.       endif
  175.       if cOktype = "D"
  176.          xNext = xNext - {01/01/01}
  177.       endif
  178.       nTot = nTot + xNext
  179.       nCount = nCount + 1
  180.    enddo
  181.  
  182. RETURN iif( nCount = 0, .F., nTot / nCount ;
  183.      + iif( cOktype = "D", {01/01/01}, 0 ) )
  184. *-- EoF: Amean()
  185.  
  186. FUNCTION Amax
  187. *-------------------------------------------------------------------------------
  188. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  189. *-- Date........: 04/13/1992
  190. *-- Notes.......: Finds maximum non-blank numeric, date or character value in
  191. *--             : specified row or column of a specified array.  If the first
  192. *--             : value is character or date, considers only that type.
  193. *--             : If first value is numeric or float, considers only numerics
  194. *--             : and floats.  Exits returning .F. if first value is logical,
  195. *--             : if specified row or column does not exist or if there are no
  196. *               : numeric, date or character values in the row or column.
  197. *-- Written for.: dBASE IV Version 1.5.
  198. *-- Rev. History: Original function written 1990
  199. *--             : Adapted to Version 1.5 4/13/1992
  200. *-- Calls       : AMASK()              Function in ARRAY.PRG
  201. *-- Called by...: Any
  202. *-- Usage.......: Amax( <cArrayskel> )
  203. *-- Example.....: ? Amax( "Myarray [ , 1 ]" )
  204. *-- Returns     : a char, numeric, float or date value, the maximum, or .F.
  205. *--             : If any of the numeric items are floats, the result will be.
  206. *-- Parameters..: cArrayskel, a character string including the name of the
  207. *--             : array and, if the row or column to be used is not the
  208. *--             : first row, a bracketed expression with a number indicating
  209. *--             : the row, or column if the number is preceded by a comma,
  210. *--             : to be used.
  211. *-------------------------------------------------------------------------------
  212.  
  213.    parameters cArrayskel
  214.    private nAt,cArray,cMask,cElem,xMax,xNext,cOktype
  215.    cArray = cArrayskel
  216.    if "[" $ cArray
  217.       cArray = left( cArray, at( "[", cArray ) - 1 )
  218.    endif
  219.    cArray = trim( ltrim( cArray ) )
  220.    cMask = Amask( cArrayskel, "nAt" )
  221.    store 0 to nAt
  222.    do while .T.
  223.       nAt = nAt + 1
  224.       cElem = cArray + cMask
  225.       xNext = type( cElem )
  226.       do case
  227.          case xNext = "U"
  228.             exit
  229.          case nAt = 1
  230.             if xNext ="L"
  231.                exit
  232.             else
  233.                cOktype = iif( xNext $ "CD", xNext, "NF" )
  234.             endif
  235.          case .not. xNext $ cOktype
  236.             loop
  237.       endcase
  238.       xNext = &cElem
  239.       if cOktype # "C" .and. isblank( xNext )
  240.          loop
  241.       endif
  242.       if nAt = 1
  243.          xMax = xNext
  244.       else
  245.          xMax = max( xMax, xNext )
  246.       endif
  247.    enddo
  248.  
  249. RETURN iif( type( "xMax" ) = "U", .F., xMax )
  250. *-- EoF: Amax()
  251.  
  252. FUNCTION Amin
  253. *-------------------------------------------------------------------------------
  254. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  255. *-- Date........: 04/13/1992
  256. *-- Notes.......: Finds minimum non-blank numeric, date or character value in
  257. *--             : specified row or column of a specified array.  If the first
  258. *--             : value is character or date, considers only that type.
  259. *--             : If first value is numeric or float, considers only numerics
  260. *--             : and floats.  Exits returning .F. if first value is logical,
  261. *--             : if specified row or column does not exist or if there are no
  262. *               : numeric, date or character values in the row or column.
  263. *-- Written for.: dBASE IV Version 1.5.
  264. *-- Rev. History: Original function written 1990
  265. *--             : Adapted to Version 1.5 4/13/1992
  266. *-- Calls       : AMASK()                 Function in ARRAY.PRG
  267. *-- Called by...: Any
  268. *-- Usage.......: Amin( <cArrayskel> )
  269. *-- Example.....: ? Amin( "Myarray [ , 1 ]" )
  270. *-- Returns     : a char, numeric, float or date value, the minimum, or .F.
  271. *--             : If any of the numeric items are floats, the result will be.
  272. *-- Parameters..: cArrayskel, a character string including the name of the
  273. *--             : array and, if the row or column to be used is not the
  274. *--             : first row, a bracketed expression with a number indicating
  275. *--             : the row, or column if the number is preceded by a comma,
  276. *--             : to be used.
  277. *-------------------------------------------------------------------------------
  278.  
  279.    parameters cArrayskel
  280.    private nAt,cArray,cMask,cElem,xMin,xNext,cOktype
  281.    cArray = cArrayskel
  282.    if "[" $ cArray
  283.       cArray = left( cArray, at( "[", cArray ) - 1 )
  284.    endif
  285.    cArray = trim( ltrim( cArray ) )
  286.    cMask = Amask( cArrayskel, "nAt" )
  287.    store 0 to nAt
  288.    do while .T.
  289.       nAt = nAt + 1
  290.       cElem = cArray + cMask
  291.       xNext = type( cElem )
  292.       do case
  293.          case xNext = "U"
  294.             exit
  295.          case nAt = 1
  296.             if xNext ="L"
  297.                exit
  298.             else
  299.                cOktype = iif( xNext $ "CD", xNext, "NF" )
  300.             endif
  301.          case .not. xNext $ cOktype
  302.             loop
  303.       endcase
  304.       xNext = &cElem
  305.       if cOktype # "C" .and. isblank( xNext )
  306.          loop
  307.       endif
  308.       if nAt = 1
  309.          xMin = xNext
  310.       else
  311.          xMin = min( xMin, xNext )
  312.       endif
  313.    enddo
  314.  
  315. RETURN iif( type( "xMin" ) = "U", .F., xMin )
  316. *-- EoF: Amin()
  317.  
  318. FUNCTION Avar
  319. *-------------------------------------------------------------------------------
  320. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  321. *-- Date........: 04/13/1992
  322. *-- Notes.......: Finds population variance of non-blank numeric or date values
  323. *--             : in specified row or column of a specified array.  If first
  324. *--             : value is date, considers only that type.
  325. *--             : If first value is numeric or float, considers only numerics
  326. *--             : and floats.  Exits returning .F. if first value is character
  327. *--             : or logical, if specified row or column does not exist or if
  328. *--             : there are no numeric or date values in the row or column.
  329. *--             :
  330. *--             : To adapt this to find the sample variance, substitute
  331. *--             : "( nCount - 1 )" for the final "nCount" in the last line.
  332. *-- Written for.: dBASE IV Version 1.5.
  333. *-- Rev. History: Original function written 1990
  334. *--             : Adapted to Version 1.5 4/13/1992
  335. *-- Calls       : AMASK()                 Function in ARRAY.PRG
  336. *-- Called by...: Any
  337. *-- Usage.......: Avar( <cArrayskel> )
  338. *-- Example.....: ? Avar( "Myarray [ , 1 ]" )
  339. *-- Returns     : a numeric, or float value, the variance, or .F.
  340. *--             : If any of the numeric items are floats, the result will be.
  341. *-- Parameters..: cArrayskel, a character string including the name of the
  342. *--             : array and, if the row or column to be used is not the
  343. *--             : first row, a bracketed expression with a number indicating
  344. *--             : the row, or column if the number is preceded by a comma,
  345. *--             : to be used.
  346. *-------------------------------------------------------------------------------
  347.  
  348.    parameters cArrayskel
  349.    private nAt,cArray,cMask,cElem,nCount,nTot,nTotsq,xNext,cOktype
  350.    cArray = cArrayskel
  351.    if "[" $ cArray
  352.       cArray = left( cArray, at( "[", cArray ) - 1 )
  353.    endif
  354.    cArray = trim( ltrim( cArray ) )
  355.    cMask = Amask( cArrayskel, "nAt" )
  356.    store 0 to nTot, nTotsq, nCount, nAt
  357.    do while .t.
  358.       nAt = nAt + 1
  359.       cElem = cArray + cMask
  360.       xNext = type( cElem )
  361.       do case
  362.          case xNext = "U"
  363.             exit
  364.          case nAt = 1
  365.             if xNext $ "CL"
  366.                exit
  367.             else
  368.                cOktype = iif( xNext = "D", "D", "NF" )
  369.             endif
  370.          case .not. xNext $ cOktype
  371.             loop
  372.       endcase
  373.       xNext = &cElem
  374.       if isblank( xNext )
  375.          loop
  376.       endif
  377.       if cOktype = "D"
  378.          xNext = xNext - {01/01/01}
  379.       endif
  380.       nTot = nTot + xNext
  381.       nTotsq = nTotsq + xNext * xNext
  382.       nCount = nCount + 1
  383.    enddo
  384.  
  385. RETURN iif( nCount = 0, .F., ( nTotsq - nTot * nTot / nCount ) / nCount )
  386. *-- EoF: Avar()
  387.  
  388. FUNCTION Aseek
  389. *-------------------------------------------------------------------------------
  390. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  391. *-- Date........: 04/21/1992
  392. *-- Notes.......: Binary search of an array for an element of which the
  393. *--               value is Finditem (could be character, numeric or date,
  394. *--               but of course types of all elements must match).  Works
  395. *--               only if array is sorted ascending.  Element found is
  396. *--               not necessarily the first that matches the value sought.
  397. *--               To use with array sorted descending, change ">" to "<"
  398. *--               in the remarked line.
  399. *-- Written for.: dBASE IV, 1.1
  400. *-- Rev. History: 03/01/1992 - original function.
  401. *--               04/21/1992 - Jay Parsons - calling syntax changed
  402. *-- Calls.......: AMASK()           Function in ARRAY.PRG
  403. *-- Called by...: Any
  404. *-- Usage.......: Aseek(<cArrayskel>,<xFindItem> )
  405. *-- Example.....: nIndex = Aseek("MyArray [ ,2 ], {01/15/89} )
  406. *-- Returns.....: numeric ( index to place in array where item exists, or 0 )
  407. *-- Parameters..: cArrayskel = name of array and optional row/column info
  408. *--               xFindItem  = Item to look for in array
  409. *--                            Must be same TYPE as item in array looked for.
  410. *--                            Numerics are NOT the same as floats for this one.
  411. *-------------------------------------------------------------------------------
  412.  
  413.    parameters cArrayskel, xFinditem
  414.    private cArray, cMask, cElem, nHi, nLo, nTrial, cOktype
  415.    cArray = cArrayskel
  416.    if "[" $ cArray
  417.       cArray = left( cArray, at( "[", cArray ) - 1 )
  418.    endif
  419.    cArray = trim( ltrim( cArray ) )
  420.    cMask = Amask( cArrayskel, "nTrial" )
  421.    cOktype = type( "xFinditem" )
  422.    nLo = 1
  423.    nHi = 1170
  424.    do while .t.
  425.       if nHi < nLo
  426.          nTrial = 0
  427.          exit
  428.       else
  429.          nTrial = int( ( nHi + nLo ) / 2 )
  430.       endif
  431.       cElem = cArray + cMask
  432.       xNext = type( cElem )
  433.       do case
  434.          case xNext = "U"
  435.             nHi = nTrial - 1
  436.          case .not. xNext $ cOktype
  437.             nTrial = 0
  438.             exit
  439.          otherwise
  440.             xNext = &cElem
  441.             do case
  442.                case xNext = xFinditem
  443.                   exit
  444.                case xNext > xFinditem   && see notes
  445.                   nHi = nTrial - 1
  446.                otherwise
  447.                   nLo = nTrial + 1
  448.             endcase
  449.       endcase
  450.    enddo
  451.  
  452. RETURN nTrial
  453. *-- EoF: Aseek
  454.  
  455. FUNCTION Ashuffle
  456. *-------------------------------------------------------------------------------
  457. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  458. *-- Date........: 03/01/1992
  459. *-- Notes.......: Random shuffle of elements of an array
  460. *-- Written for.: dBASE IV, 1.1
  461. *-- Rev. History: None
  462. *-- Calls.......: Amask()           Function in ARRAY.PRG
  463. *--               Arrayrows()       Function in ARRAY.PRG
  464. *--               Arraycols()       Function in ARRAY.PRG
  465. *-- Called by...: Any
  466. *-- Usage.......: AShuffle( "<cArrayskel>" )
  467. *-- Example.....: lX = AShuffle( "aTest[ ,2]" )
  468. *-- Returns.....: .T.
  469. *-- Parameters..: cArrayskel = Name of array, optional row/column designator
  470. *-- Side effects: Rearranges elements of the array
  471. *--               Reseeds random number generator and uses some random numbers
  472. *-------------------------------------------------------------------------------
  473.  
  474.    parameters cArrayskel
  475.    private cArray, cMask, cElem, cElem, nAt, nRand, nLeft, x1, x2
  476.    cArray = cArrayskel
  477.    if "[" $ cArray
  478.       cArray = left( cArray, at( "[", cArray ) - 1 )
  479.    endif
  480.    cArray = trim( ltrim( cArray ) )
  481.    cMask = Amask( cArrayskel, "nAt" )
  482.    if at( ",", cMask ) > 0 .and. val( substr( cMask, at( ",", cMask ) + 1 ) ) = 0
  483.       nLeft = Arraycols( cArray )
  484.    else
  485.       nLeft = Arrayrows( cArray )
  486.    endif
  487.    nRand =  rand( -1 )
  488.    do while nLeft > 1
  489.       nAt = nLeft
  490.       cElem = cArray + cMask
  491.       x1 = &cElem
  492.       nAt = int( rand() * nLeft ) + 1
  493.       cElem = cArray + cMask
  494.       x2 = &cElem
  495.       store x1 to &cElem
  496.       nAt = nLeft
  497.       cElem = cArray + cMask
  498.       store x2 to &cElem
  499.       nLeft = nLeft - 1
  500.    enddo
  501.  
  502. RETURN .T.
  503. *-- EoF: Ashuffle()
  504.  
  505. FUNCTION Abubble
  506. *-------------------------------------------------------------------------------
  507. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  508. *-- Date........: 04/21/1992
  509. *-- Notes.......: Bubble sort.  This is a slow algorithm, made slower by 
  510. *--               passing the array name as a parameter instead of copying 
  511. *--               the array to one of predefined name.  Its primary use is in 
  512. *--               selecting a few of the highest or lowest values from a longer
  513. *--               list.  The argument "nPasses" gives the number of values
  514. *--               guaranteed to be in their correct places, in this case the 
  515. *--               lowest values, at the head of the list. Values at other
  516. *--               places in the list may not have been sorted.
  517. *--               Note: To place the highest values at the head of
  518. *--               the list, change > to < in the remarked line.
  519. *--               What use is it?  Well, a golf handicap is based on
  520. *--               the lowest 10 score differentials of the last 20.
  521. *--               This is the easy way to select them.  Other applications
  522. *--               include selecting a few invidividuals from a large number
  523. *--               of candidates based on some numeric expression.
  524. *-- Written for.: dBASE IV, 1.1, 1.5
  525. *-- Rev. History: None
  526. *-- Calls.......: AMASK()           Function in ARRAY.PRG
  527. *--               Arraycols()       Function in ARRAY.PRG
  528. *--               Arrayrows()       Function in ARRAY.PRG
  529. *-- Called by...: Any
  530. *-- Usage.......: BubbleSort("<cArrayskel>" [,<nPass>] )
  531. *-- Example.....: lX = BubbleSort("Test [1,]",10)
  532. *-- Returns.....: .T.
  533. *-- Parameters..: cArrayskel = Name of array, optional row/column designator
  534. *--               nPasses    = number of passes. If you want a complete sort,
  535. *--                            set this value to the same as length of array,
  536. *--                            or omit it in 1.5.
  537. *-- Side effects: Rearranges elements of the array
  538. *-------------------------------------------------------------------------------
  539.  
  540.    parameters cArrayskel, nPasses
  541.    private nJ, nAt, cArray, cMask, cElem, x1, x2, nP, nPasses, lSwitch, nOld, nNew
  542.    cArray = cArrayskel
  543.    if "[" $ cArray
  544.       cArray = left( cArray, at( "[", cArray ) - 1 )
  545.    endif
  546.    cArray = trim( ltrim( cArray ) )
  547.    cMask = Amask( cArrayskel, "nAt" )
  548.    if at( ",", cMask ) > 0 .and. val( substr( cMask, at( ",", cMask ) + 1 ) ) = 0
  549.       nJ = Arraycols( cArray )
  550.    else
  551.       nJ = Arrayrows( cArray )
  552.    endif
  553.    if val( substr( version(), 9, 5 ) ) < 1.5 .or. pcount() > 1
  554.       nP = min( nPasses, nJ )
  555.    else
  556.       nP = nJ
  557.    endif
  558.    nPass = 1
  559.    do while nPass <= nP
  560.       lSwitch = .F.
  561.       nOld = nJ
  562.       do while .t.
  563.          cElem = cArray + cMask
  564.          nAt = nOld
  565.          x1 = &cElem
  566.          do while .t.
  567.             nNew = nOld - 1
  568.             if nNew < nPass
  569.                exit
  570.             endif
  571.             nAt = nNew
  572.             cElem = cArray + cMask
  573.             x2 = &cElem
  574.             if x1 < x2        && see notes
  575.                lSwitch = .T.
  576.                nAt = nOld
  577.                cElem = cArray + cMask
  578.                store x2 to &cElem
  579.                nOld = nNew
  580.             else
  581.                exit
  582.             endif
  583.          enddo
  584.          nAt = nOld
  585.          cElem = cArray + cMask
  586.          store x1 to &cElem
  587.          nOld = nNew
  588.          if nOld <= nPass
  589.             exit
  590.          endif
  591.       enddo
  592.       if .not. lSwitch
  593.          exit
  594.       endif
  595.       nPass = nPass + 1
  596.    enddo
  597.     
  598. RETURN .T.
  599. *-- EoF: Abubble()
  600.  
  601. FUNCTION ArrayRows
  602. *-------------------------------------------------------------------------------
  603. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  604. *-- Date........: 03/01/1992
  605. *-- Notes.......: Number of Rows in an array
  606. *-- Written for.: dBASE IV, 1.1
  607. *-- Rev. History: None
  608. *-- Calls.......: None
  609. *-- Called by...: Any
  610. *-- Usage.......: ArrayRows("<aArray>")
  611. *-- Example.....: n = ArrayRows("aTest")
  612. *-- Returns.....: numeric
  613. *-- Parameters..: aArray      = Name of array 
  614. *-------------------------------------------------------------------------------
  615.  
  616.     parameters aArray
  617.     private nHi, nLo, nTrial, nDims
  618.     nLo = 1
  619.     nHi = 1170
  620.     if type( "&aArray[ 1, 1 ]" ) = "U"
  621.       nDims = 1
  622.     else
  623.      nDims = 2
  624.     endif
  625.     do while .T.
  626.      nTrial = int( ( nHi + nLo ) / 2 )
  627.       if nHi < nLo
  628.         exit
  629.       endif
  630.      if nDims = 1 .and. type( "&aArray[ nTrial ]" ) = "U" .or. ;
  631.        nDims = 2 .and. type( "&aArray[ nTrial, 1 ]" ) = "U"
  632.         nHi = nTrial - 1
  633.       else
  634.         nLo = nTrial + 1
  635.       endif
  636.     enddo
  637.     
  638. RETURN nTrial
  639. *-- EoF: ArrayRows()
  640.  
  641. FUNCTION ArrayCols
  642. *-------------------------------------------------------------------------------
  643. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  644. *-- Date........: 03/01/1992
  645. *-- Notes.......: Number of Columns in an array
  646. *-- Written for.: dBASE IV, 1.1
  647. *-- Rev. History: None
  648. *-- Calls.......: None
  649. *-- Called by...: Any
  650. *-- Usage.......: ArrayCols("<aArray>")
  651. *-- Example.....: n = ArrayCols("aTest")
  652. *-- Returns.....: numeric
  653. *-- Parameters..: aArray      = Name of array 
  654. *-------------------------------------------------------------------------------
  655.  
  656.     parameters aArray
  657.    private nHi, nLo, nTrial
  658.     nLo = 1
  659.     nHi = 1170
  660.     if type( "&aArray[ 1, 1 ]" ) = "U"
  661.       RETURN 0
  662.     endif
  663.     do while .t.
  664.       nTrial = int( ( nHi + nLo ) / 2 )
  665.       if nHi < nLo
  666.          exit
  667.       endif
  668.       if type( "&aArray[ 1, nTrial ]" ) = "U"
  669.         nHi = nTrial - 1
  670.       else
  671.         nLo = nTrial + 1
  672.       endif
  673.     enddo
  674.  
  675. RETURN nTrial
  676. *-- EoF: ArrayCol()
  677.                                    
  678. FUNCTION ShellSort
  679. *-------------------------------------------------------------------------------
  680. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  681. *-- Date........: 03/01/1992
  682. *-- Notes.......: Sort aMyarray[] elements 1 to Number, ascending
  683. *--               Note: change < to > in the remarked line for
  684. *--               a descending sort.
  685. *--               This routine depends on the elements being copied
  686. *--               into the array "aMyarray" before the sort.  It could,
  687. *--               like the other array functions, accept the name of
  688. *--               the array as a parameter and use it as a macro within,
  689. *--               but performance will be very slow in that case.
  690. *-- Written for.: dBASE IV, 1.1
  691. *-- Rev. History: None
  692. *-- Calls.......: None
  693. *-- Called by...: Any
  694. *-- Usage.......: ShellSort(<nNumber>)
  695. *-- Example.....: lX = ShellSort(532)
  696. *-- Returns.....: .T.
  697. *-- Parameters..: nNumber    = Size of array (# of elements)
  698. *-------------------------------------------------------------------------------
  699.  
  700.     parameters nNumber
  701.     private nInterval, nPlace, nI, nJ, xTemp
  702.     nInterval = nNumber
  703.     do while nInterval > 0
  704.       nInterval = int( nInterval / 2 )
  705.       nPlace = 1
  706.       do while .T.
  707.         nI = nPlace
  708.         nJ = nI + nInterval
  709.         if nJ > nNumber
  710.           exit
  711.         endif
  712.         xTemp = aMyarray[ nJ, 1 ]
  713.         do while xTemp < aMyarray[ nI, 1 ]  && see note
  714.           aMyarray[ nJ,1 ] = aMyarray[ nI, 1 ]
  715.           nJ = nI
  716.           nI = nI - nInterval
  717.           if nI < 1
  718.             exit
  719.           endif
  720.         enddo
  721.         aMyarray[ nJ, 1 ] = xTemp
  722.         nPlace = nPlace + 1
  723.       enddo
  724.     enddo
  725.  
  726. RETURN .T.
  727. *-- EoF: ShellSort()
  728.  
  729. FUNCTION Arec2Arr
  730. *-------------------------------------------------------------------------------
  731. *-- Programmer..: Bowen Moursund (CIS: 76566,1405)
  732. *-- Date........: 05/01/1992
  733. *-- Notes.......: Creates a public array, aRecord[n], initialized to the
  734. *--               record format of the currently selected DBF, either blank or
  735. *--               filled with the values of the current record. Memo fields
  736. *--               cannot be copied to an array.
  737. *-- Written for.: dBASE IV v1.5
  738. *-- Rev. History: None
  739. *-- Calls.......: None
  740. *-- Called by...: Any
  741. *-- Usage.......: Arec2Arr(<lBlank>)
  742. *-- Example.....: lSuccess = Arec2Arr(.T.)
  743. *-- Returns.....: .T. if succesful, .F. if not.
  744. *-- Parameters..: lBlank = whether or not to create an empty array.
  745. *--                        .T. = blank
  746. *--                        .F. = current record values
  747. *-- Side effects: Creates a public array, aRecord[n]. It will destroy
  748. *--               an existing array of that name.
  749. *-------------------------------------------------------------------------------
  750.  
  751.     parameters lBlank
  752.     private lSuccess,lDbf,cFieldName,nFieldNumb,nNumFields
  753.     lSuccess = .f.
  754.     lDbf = ( "" # dbf() )
  755.     if ((lDbf .and. lBlank) .or. (.not. lBlank .and. lDbf .and. .not. eof()))
  756.         release aRecord
  757.         nNumFields = fldcount()
  758.         public array aRecord[nNumFields]
  759.         if lBlank
  760.             goto bottom
  761.             skip         && phantom record
  762.             nFieldNumb=1
  763.             do while nFieldNumb <= nNumFields
  764.                 cFieldName = field(nFieldNumb)
  765.                 aRecord[nFieldNumb] = &cFieldName.
  766.                 nFieldNumb = nFieldNumb + 1
  767.             enddo
  768.         else
  769.             copy to array aRecord next 1
  770.         endif
  771.         lSuccess = .t.
  772.     endif
  773.  
  774. RETURN lSuccess
  775. *-- EoF: Arec2Arr()
  776.  
  777. FUNCTION aPullSort
  778. *-------------------------------------------------------------------------------
  779. *-- Programmer..: Kelvin Smith (KELVIN)
  780. *-- Date........: 05/07/1992
  781. *-- Notes.......: Sort aMyarray[] elements 1 to Number, ascending
  782. *--                 Note: change > to < in the remarked line for
  783. *--               a descending sort.
  784. *--               This sorting algorithm, while not as fast as a shell
  785. *--               sort, is fairly simple to understand and considerably
  786. *--               faster than the infamous bubble sort.  Each iteration
  787. *--               pulls the next item in order to the front of the unsorted
  788. *--               portion of the list.
  789. *--                 This routine depends on the elements being copied
  790. *--               into the array "aMyarray" before the sort.  It could,
  791. *--               like the other array functions, accept the name of
  792. *--               the array as a parameter and use it as a macro within,
  793. *--               but performance will be very slow in that case.
  794. *-- Written for.: dBASE IV, 1.5
  795. *-- Rev. History: None
  796. *-- Calls.......: None
  797. *-- Called by...: Any
  798. *-- Usage.......: APullSort(<nNumber>)
  799. *-- Example.....: lX = APullSort(532)
  800. *-- Returns.....: .T.
  801. *-- Parameters..: nNumber    = Size of array (# of elements)
  802. *-------------------------------------------------------------------------------
  803.  
  804.     parameters nNumber
  805.     private nI, nJ, nSwap, xTemp
  806.     nI = 1
  807.     do while nI < nNumber                   && Through the list
  808.        nSwap = nI
  809.        nJ = nI + 1
  810.        do while nJ <= nNumber               && From nI to end of list
  811.           if aMyarray[nSwap] > aMyarray[nJ]    && see note
  812.              nSwap = nJ                     && Item at nJ is smaller
  813.           endif
  814.           nJ = nJ + 1
  815.        enddo
  816.        if nSwap <> nI                       && Found a smaller one
  817.           xTemp = aMyarray[nSwap]           && Swap it
  818.           aMyarray[nSwap] = aMyarray[nI]
  819.           aMyarray[nI] = xTemp
  820.        endif
  821.        nI = nI + 1
  822.     enddo
  823.  
  824. RETURN .T.
  825. *-- EoF: APullSort()
  826.  
  827. *-------------------------------------------------------------------------------
  828. *-- EoP: ARRAY.PRG
  829. *-------------------------------------------------------------------------------
  830.